home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / slatex / defrecor.ss < prev    next >
Text File  |  1993-11-07  |  4KB  |  123 lines
  1. ;defrecor.ss
  2. ;enums, records, setf
  3. ;(c) Dorai Sitaram, December 1991, Rice University
  4.  
  5. ;defenum
  6.  
  7. '(enable chez scmx)
  8. (extend-syntax (defenum)
  9.   ;(defenum x ...) defines x ... to be distinct objects that can
  10.   ;be used as a (C-like) enumerated datatype
  11.   ((defenum (1) () n ((x i) ...))
  12.    (begin (define x (integer->char i)) ...))
  13.   ((defenum (1) (x . more-x) i x-i-pairs)
  14.    (defenum (1) more-x (+ i 1) ((x i) . x-i-pairs)))
  15.   ((defenum . xs)
  16.    (defenum (1) xs 0 ())))
  17.  
  18. '(enable cl)
  19. (define-macro! defenum z
  20.   ;(let loop ...) doesn't work in macro transformer, hence the do
  21.   (do ((z z (cdr z))
  22.        (n 0 (+ n 1))
  23.        (r '() (cons `(define ,(car z) (integer->char ,n)) r)))
  24.       ((null? z) `(begin ,@r))))
  25.  
  26. '(disable chez cl scmx)
  27. (define-macro! defenum z
  28.   (let loop ((z z) (n 0) (r '()))
  29.     (if (null? z) `(begin ,@r)
  30.       (loop (cdr z) (+ n 1) 
  31.     (cons `(define ,(car z) (integer->char ,n)) r)))))
  32.  
  33. ;defrecord
  34.  
  35. '(enable chez scmx)
  36. (extend-syntax (defrecord)
  37.   ;(defrecord n f ...) defines a thunk n that creates a record
  38.   ;with fields f ...
  39.   ((defrecord (1) name () n ((f i) ...))
  40.    (begin (define name (lambda () (make-vector n)))
  41.       (define f i) ...))
  42.   ((defrecord (1) name (f . more-f) i f-i-pairs)
  43.    (defrecord (1) name more-f (+ i 1) ((f i) . f-i-pairs)))
  44.   ((defrecord name . fields)
  45.    (defrecord (1) name fields 0 ())))
  46.  
  47. '(enable cl)
  48. (define-macro! defrecord (name . fields)
  49.   (do ((fields fields (cdr fields))
  50.        (i 0 (+ i 1))
  51.        (r '() (cons `(define ,(car fields) ,i) r)))
  52.       ((null? fields)
  53.        `(begin (define ,name (lambda () (make-vector ,i)))
  54.            ,@r))))
  55.  
  56. '(disable chez cl scmx)
  57. (define-macro! defrecord (name . fields)
  58.   (let loop ((fields fields) (i 0) (r '()))
  59.     (if (null? fields)
  60.     `(begin (define ,name (lambda () (make-vector ,i)))
  61.         ,@r)
  62.     (loop (cdr fields) (+ i 1)
  63.       (cons `(define ,(car fields) ,i) r)))))
  64.  
  65. ;of
  66.  
  67. '(enable chez scmx)
  68. (extend-syntax (of /)
  69.   ;of is used to access record fields
  70.   ((of s i) (vector-ref s i))
  71.   ((of s / i) (string-ref s i))
  72.   ((of s i . z) (of (vector-ref s i) . z)))
  73.  
  74. '(disable chez scmx)
  75. (define-macro! of (r i . z)
  76.   (cond ((null? z) `(vector-ref ,r ,i))
  77.     ((and (eq? i '/) (= (length z) 1)) 
  78.      `(string-ref ,r ,(car z)))
  79.     (else `(of (vector-ref ,r ,i) ,@z))))
  80.  
  81. ;setf
  82.  
  83. '(enable cl)
  84. (begin
  85.   (defsetf list-ref list-set!)
  86.   (defsetf string-ref string-set!)
  87.   (defsetf vector-ref vector-set!))
  88.   
  89. '(enable chez scmx)
  90. (extend-syntax (setf list-ref string-ref vector-ref of)
  91.   ((setf (list-ref l i) r) (list-set! l i r))
  92.   ((setf (string-ref s i) r) (string-set! s i r))
  93.   ((setf (vector-ref v i) r) (vector-set! v i r))
  94.   ((setf (of z ...) r) (the-setter-for-of z ... r))
  95.   ((setf l r) (set! l r)))
  96.  
  97. '(disable chez cl scmx)
  98. (define-macro! setf (l r)
  99.   (if (symbol? l) `(set! ,l ,r)
  100.     (let ((a (car l)))
  101.       `(,(cond ((eq? a 'list-ref) 'list-set!)
  102.            ((eq? a 'string-ref) 'string-set!)
  103.            ((eq? a 'vector-ref) 'vector-set!)
  104.            ((eq? a 'of) 'the-setter-for-of)
  105.            (else (lerror 'setf)))
  106.     ,@(cdr l) ,r))))
  107.  
  108. ;the-setter-for-of
  109.  
  110. '(enable chez scmx)
  111. (extend-syntax (the-setter-for-of)
  112.   ((the-setter-for-of s i v) (vector-set! s i v))
  113.   ((the-setter-for-of s / i v) (string-set! s i v))
  114.   ((the-setter-for-of s i . z)
  115.    (the-setter-for-of (vector-ref s i) . z)))
  116.  
  117. '(disable chez cl scmx)
  118. (define-macro! the-setter-for-of (r i j . z)
  119.   (cond ((null? z) `(vector-set! ,r ,i ,j))
  120.     ((and (eq? i '/) (= (length z) 1))
  121.      `(string-set! ,r ,j ,(car z)))
  122.     (else `(the-setter-for-of (vector-ref ,r ,i) ,j ,@z))))     
  123.